Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH10/SRC/SURFACE2.FRM

Text File | 1996-05-02 | 17KB | 637 lines

VERSION 4.00
Begin VB.Form SurfaceForm
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Surfaces"
   ClientHeight    =   5700
   ClientLeft      =   300
   ClientTop       =   855
   ClientWidth     =   9090
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6390
   KeyPreview      =   -1  'True
   Left            =   240
   LinkTopic       =   "Form1"
   ScaleHeight     =   5700
   ScaleWidth      =   9090
   Top             =   225
   Width           =   9210
   Begin VB.CheckBox ShowAxesCheck
      Caption         =   "Show Axes"
      Height          =   255
      Left            =   7080
      TabIndex        =   16
      Top             =   3960
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Saddle"
      Height          =   255
      Index           =   8
      Left            =   7080
      TabIndex        =   15
      Top             =   2880
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Cone"
      Height          =   255
      Index           =   7
      Left            =   7080
      TabIndex        =   14
      Top             =   2520
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Holes"
      Height          =   255
      Index           =   6
      Left            =   7080
      TabIndex        =   13
      Top             =   2160
      Width           =   2055
   End
   Begin VB.TextBox PhiText
      Height          =   285
      Left            =   3600
      TabIndex        =   12
      Text            =   "0.1570"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox ThetaText
      Height          =   285
      Left            =   2040
      TabIndex        =   10
      Text            =   "0.6283"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox RText
      Height          =   285
      Left            =   480
      TabIndex        =   8
      Text            =   "10"
      Top             =   5400
      Width           =   855
   End
   Begin VB.OptionButton Choice
      Caption         =   "Hemisphere"
      Height          =   255
      Index           =   5
      Left            =   7080
      TabIndex        =   7
      Top             =   1800
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Randomized Ridges"
      Height          =   255
      Index           =   4
      Left            =   7080
      TabIndex        =   6
      Top             =   1440
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Ridges"
      Height          =   255
      Index           =   3
      Left            =   7080
      TabIndex        =   5
      Top             =   1080
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Bowl"
      Height          =   255
      Index           =   2
      Left            =   7080
      TabIndex        =   4
      Top             =   720
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Mounds"
      Height          =   255
      Index           =   1
      Left            =   7080
      TabIndex        =   3
      Top             =   360
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Splash"
      Height          =   255
      Index           =   0
      Left            =   7080
      TabIndex        =   2
      Top             =   0
      Value           =   -1  'True
      Width           =   2055
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   5295
      Left            =   0
      ScaleHeight     =   349
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   461
      TabIndex        =   0
      Top             =   0
      Width           =   6975
   End
   Begin MSComDlg.CommonDialog LoadDialog
      Left            =   7080
      Top             =   4560
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label Label1
      Caption         =   "Phi"
      Height          =   255
      Index           =   2
      Left            =   3240
      TabIndex        =   11
      Top             =   5400
      Width           =   375
   End
   Begin VB.Label Label1
      Caption         =   "Theta"
      Height          =   255
      Index           =   1
      Left            =   1440
      TabIndex        =   9
      Top             =   5400
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "R"
      Height          =   255
      Index           =   0
      Left            =   240
      TabIndex        =   1
      Top             =   5400
      Width           =   255
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSaveAs
         Caption         =   "&Save As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "SurfaceForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' Location of viewing eye.
Dim EyeR As Single
Dim EyeTheta As Single
Dim EyePhi As Single

Const Dtheta = PI / 20
Const Dphi = PI / 20
Const Dr = 1

' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#

Dim Projector(1 To 4, 1 To 4) As Single

Dim ThePicture As ObjPicture

Dim ShowingParameters As Boolean

Dim ChoiceNum As Integer

' ************************************************
' Return the surface's value at this point.
' ************************************************
Function SurfaceValue(x As Single, z As Single) As Single
Const Xmin = -5
Const Amp = 0.25
Const Per = 2 * PI / 4
Const Amp2 = 1
Const Per2 = 2 * PI / 16
Const Amp3 = 2
Const R2 = 16.81

Dim D As Single
Dim x1 As Single
Dim z1 As Single
Dim x2 As Single
Dim z2 As Single
Dim y As Single

    Select Case ChoiceNum
        Case 0  ' Splash.
            D = Sqr(x * x + z * z)
            y = Amp * Cos(3 * D)

        Case 1  ' Mounds.
            y = Amp * (Cos(Per * x) + Cos(Per * z))

        Case 2  ' Bowl.
            y = 0.2 * (x * x + z * z) - 5#

        Case 3  ' Ridges.
            y = Amp2 * Cos(Per2 * x) + Amp3 * Cos(Per * z) / (Abs(z) / 3 + 1)

        Case 4  ' Random ridges.
            y = Amp2 * Cos(Per2 * x) + Amp3 * Cos(Per * z) / (Abs(z) / 3 + 1) + Amp * Rnd / 2

        Case 5  ' Hemisphere.
            D = x * x + z * z
            If D >= R2 Then
                y = 0
            Else
                y = Sqr(R2 - D)
            End If

        Case 6  ' Holes.
            x1 = (x + Xmin / 2)
            z1 = (z + Xmin / 2)
            x2 = (x - Xmin / 2)
            z2 = (z - Xmin / 2)
            y = Amp3 - _
        1 / (x1 * x1 + z1 * z1 + 0.1) - _
        1 / (x2 * x2 + z1 * z1 + 0.1) - _
        1 / (x1 * x1 + z2 * z2 + 0.1) - _
        1 / (x2 * x2 + z2 * z2 + 0.1)

        Case 7  ' Cone.
            D = 2 * (Amp3 - Sqr(x * x + z * z))
            If D < -Amp3 Then D = -Amp3
            y = D

        Case 8  ' Saddle.
            y = (x * x - z * z) / 10

    End Select

    SurfaceValue = y
End Function


' *******************************************************
' Rotate the points in the cube and draw the cube.
' *******************************************************
Private Sub DrawData(pic As Object)
Dim x As Single
Dim y As Single
Dim z As Single
Dim S(1 To 4, 1 To 4) As Single
Dim t(1 To 4, 1 To 4) As Single
Dim ST(1 To 4, 1 To 4) As Single
Dim PST(1 To 4, 1 To 4) As Single

    MousePointer = vbHourglass
    Refresh

    ' Prevent overflow errors when drawing lines
    ' too far out of bounds.
    On Error Resume Next

    ' Scale and translate so it looks OK in pixels.
    m3Scale S, 35, -35, 1
    m3Translate t, 230, 175, 0
    m3MatMultiplyFull ST, S, t
    m3MatMultiplyFull PST, Projector, ST

    ' Transform the points.
    ThePicture.ApplyFull PST

    ' Display the data.
    pic.Cls
    ThePicture.Draw pic, EyeR
    pic.Refresh

    ' Display the viewnig parameters.
    ShowViewingParameters

    MousePointer = vbDefault
End Sub

Sub ShowViewingParameters()
    ShowingParameters = True

    RText.Text = Format$(EyeR, "0.0000")
    ThetaText.Text = Format$(EyeTheta, "0.0000")
    PhiText.Text = Format$(EyePhi, "0.0000")

    RText.Refresh
    ThetaText.Refresh
    PhiText.Refresh

    ShowingParameters = False
End Sub

Private Sub Choice_Click(Index As Integer)
    ChoiceNum = Index
    CreateData (ShowAxesCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyLeft
            EyeTheta = EyeTheta - Dtheta

        Case vbKeyRight
            EyeTheta = EyeTheta + Dtheta

        Case vbKeyUp
            EyePhi = EyePhi - Dphi

        Case vbKeyDown
            EyePhi = EyePhi + Dphi

        Case Else
            Exit Sub
    End Select

    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Asc("+")
            EyeR = EyeR + Dr

        Case Asc("-")
            EyeR = EyeR - Dr

        Case Else
            Exit Sub
    End Select

    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub

Private Sub Form_Load()
    ' Initialize the eye position.
    EyeR = 10
    EyeTheta = PI * 0.2
    EyePhi = PI * 0.1

    ' Initialize the projection transformation.
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0

    ' Create the data.
    CreateData (ShowAxesCheck.value = vbChecked)

    ' Project and draw the data.
    Me.Show
    DrawData Pict
End Sub



' ************************************************
' Create the surface.
' ************************************************
Sub CreateData(show_axes As Boolean)
Const Xmin = -5     ' The area the grid should cover.
Const Zmin = -5
Const Xmax = -Xmin
Const Zmax = -Zmin
Const GapX = 0.5    ' Distance between curves parallel
Const GapZ = 0.5    '   to the X and Z axes.
Const Dx = 0.1      ' Distance between points along
Const Dz = 0.1      '   the curves.

Dim refined As ObjPicture   ' The refined grid.
Dim pline As ObjPolyline    ' A polyline in the grid.
Dim axis As ObjPolyline
Dim i As Integer
Dim j As Integer
Dim x As Single
Dim y As Single
Dim z As Single
Dim x1 As Single
Dim y1 As Single
Dim z1 As Single

    MousePointer = vbHourglass
    Refresh

    Set ThePicture = New ObjPicture
    Set refined = New ObjPicture
    ThePicture.objects.Add refined

    If show_axes Then
        Set axis = New ObjPolyline
        ThePicture.objects.Add axis
        axis.AddSegment 0, 0, 0, 5.5, 0, 0
        axis.AddSegment 0, 0, 0, 0, 3, 0
        axis.AddSegment 0, 0, 0, 0, 0, 5.5
    End If

    ' Create polylines parallel to the X axis.
    For z = Zmin To Zmax Step GapZ
        Set pline = New ObjPolyline
        refined.objects.Add pline

        x1 = Xmin
        y1 = SurfaceValue(Xmin, z)
        z1 = z

        For x = Xmin + Dx To Xmax Step Dx
            y = SurfaceValue(x, z)
            pline.AddSegment x1, y1, z1, x, y, z
            x1 = x
            y1 = y
            z1 = z
        Next x
    Next z

    ' Create polylines parallel to the Z axis.
    For x = Xmin To Xmax Step GapX
        Set pline = New ObjPolyline
        refined.objects.Add pline

        x1 = x
        y1 = SurfaceValue(x, Zmin)
        z1 = Zmin

        For z = Zmin + Dz To Zmax Step Dz
            y = SurfaceValue(x, z)
            pline.AddSegment x1, y1, z1, x, y, z
            x1 = x
            y1 = y
            z1 = z
        Next z
    Next x
End Sub

Private Sub mnuFileExit_Click()
    Unload Me
End Sub


Private Sub mnuFileLoad_Click()
Dim fname As String
Dim filenum As Integer
Dim txt As String
Dim Xmin As Single
Dim Ymin As Single
Dim Xmax As Single
Dim Ymax As Single

    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    MousePointer = vbHourglass
    DoEvents

    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)

    ' Clear the picture.
    Set ThePicture = Nothing

    ' Open the file.
    filenum = FreeFile
    Open fname For Input As #filenum

    ' Make sure it's an Object Picture File.
    Input #filenum, txt
    If txt <> "3D APF PICTURE" Then
        Close filenum
        Beep
        MsgBox "Error reading file """ & fname & """.", , vbExclamation
        Exit Sub
    End If

    ' Read the picture.
    Set ThePicture = New ObjPicture
    ThePicture.FileInput filenum

    ' Close the file.
    Close filenum

    ' Refresh the display.
    DrawData Pict

    ' Deselect all the option buttons.
    For ChoiceNum = 0 To 8
        If Choice(ChoiceNum).value Then _
            Choice(ChoiceNum).value = False
    Next ChoiceNum

    MousePointer = vbDefault
End Sub



Private Sub mnuFileSaveAs_Click()
Dim fname As String
Dim filenum As Integer

    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    LoadDialog.ShowSave
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)

    ' Open the file.
    filenum = FreeFile
    Open fname For Output As #filenum

    ' Write the picture.
    ThePicture.FileWrite filenum

    ' Close the file.
    Close filenum
End Sub



Private Sub PhiText_Change()
    If ShowingParameters Then Exit Sub
    EyePhi = CSng(PhiText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub

Private Sub RText_Change()
    If ShowingParameters Then Exit Sub
    EyeR = CSng(RText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub


Private Sub ShowAxesCheck_Click()
    CreateData (ShowAxesCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub


Private Sub ThetaText_Change()
    If ShowingParameters Then Exit Sub
    EyeTheta = CSng(ThetaText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub